Celestin Apprentice 2/Apprentice-Release2.iso/Tools/Languages/MacGofer 0.22d/MacGofer 0.22d Release/Standard Prelude

Text File | 1994-01-05 | 27.2 KB | 420 lines | [TEXT/GFER]

--         __________   __________   __________   __________   ________
--        /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
--       /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
--      /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
--     /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \
--    /_________/  /_________/  /__/         /_________/  /__/    \__\
--
--    Functional programming environment, Version 2.28
--    Copyright Mark P Jones 1991-1993.
--
--    Standard prelude for use of overloaded values using type classes.
--    Based on the Haskell standard prelude version 1.2.

help = "press :? for a list of commands"

-- Operator precedence table: -----------------------------------------------

infixl 9 !!
infixr 9 .
infixr 8 ^
infixl 7 *
infix  7 /, `div`, `quot`, `rem`, `mod`
infixl 6 +, -
infix  5 \\
infixr 5 ++, :
infix  4 ==, /=, <, <=, >=, >
infix  4 `elem`, `notElem`
infixr 3 &&
infixr 2 ||
infixr 0 $

-- Standard combinators: ----------------------------------------------------

primitive strict "primStrict" :: (a -> b) -> a -> b

const          :: a -> b -> a
const k x       = k

id             :: a -> a
id    x         = x

curry          :: ((a,b) -> c) -> a -> b -> c
curry f a b     =  f (a,b)

uncurry        :: (a -> b -> c) -> (a,b) -> c
uncurry f (a,b) = f a b

fst            :: (a,b) -> a
fst (x,_)       = x

snd            :: (a,b) -> b
snd (_,y)       = y

fst3           :: (a,b,c) -> a
fst3 (x,_,_)    = x

snd3           :: (a,b,c) -> b
snd3 (_,x,_)    = x

thd3           :: (a,b,c) -> c
thd3 (_,_,x)    = x

(.)           :: (b -> c) -> (a -> b) -> (a -> c)
(f . g) x       = f (g x)

flip           :: (a -> b -> c) -> b -> a -> c
flip  f x y     = f y x

($)            :: (a -> b) -> a -> b     -- pronounced as `apply' elsewhere
f $ x           = f x

-- Boolean functions: -------------------------------------------------------

(&&), (||)     :: Bool -> Bool -> Bool
False && x      = False
True  && x      = x

False || x      = x
True  || x      = True

not            :: Bool -> Bool
not True        = False
not False       = True

and, or        :: [Bool] -> Bool
and             = foldr (&&) True
or              = foldr (||) False

any, all       :: (a -> Bool) -> [a] -> Bool
any p           = or  . map p
all p           = and . map p

otherwise      :: Bool
otherwise       = True

-- Character functions: -----------------------------------------------------

primitive ord "primCharToInt" :: Char -> Int
primitive chr "primIntToChar" :: Int -> Char

isAscii, isControl, isPrint, isSpace            :: Char -> Bool
isUpper, isLower, isAlpha, isDigit, isAlphanum  :: Char -> Bool

isAscii c     =  ord c < 128

isControl c   =  c < ' '    ||  c == '\DEL'

isPrint c     =  c >= ' '   &&  c <= '~'

isSpace c     =  c == ' '   || c == '\t'  || c == '\n'  || c == '\r'  ||
                               c == '\f'  || c == '\v'

isUpper c     =  c >= 'A'   &&  c <= 'Z'
isLower c     =  c >= 'a'   &&  c <= 'z'

isAlpha c     =  isUpper c  ||  isLower c
isDigit c     =  c >= '0'   &&  c <= '9'
isAlphanum c  =  isAlpha c  ||  isDigit c


toUpper, toLower      :: Char -> Char

toUpper c | isLower c  = chr (ord c - ord 'a' + ord 'A')
          | otherwise  = c

toLower c | isUpper c  = chr (ord c - ord 'A' + ord 'a')
          | otherwise  = c

minChar, maxChar      :: Char
minChar                = chr 0
maxChar                = chr 255

-- Standard type classes: ---------------------------------------------------

class Eq a where
    (==), (/=) :: a -> a -> Bool
    x /= y      = not (x == y)

class Eq a => Ord a where
    (<), (<=), (>), (>=) :: a -> a -> Bool
    max, min             :: a -> a -> a

    x <  y            = x <= y && x /= y
    x >= y            = y <= x
    x >  y            = y < x

    max x y | x >= y  = x
            | y >= x  = y
    min x y | x <= y  = x
            | y <= x  = y

class Ord a => Ix a where
    range   :: (a,a) -> [a]
    index   :: (a,a) -> a -> Int
    inRange :: (a,a) -> a -> Bool

class Ord a => Enum a where
    enumFrom       :: a -> [a]              -- [n..]
    enumFromThen   :: a -> a -> [a]         -- [n,m..]
    enumFromTo     :: a -> a -> [a]         -- [n..m]
    enumFromThenTo :: a -> a -> a -> [a]    -- [n,n'..m]

    enumFromTo n m        = takeWhile (m>=) (enumFrom n)
    enumFromThenTo n n' m = takeWhile ((if n'>=n then (>=) else (<=)) m)
                                      (enumFromThen n n')

class (Eq a, Text a) => Num a where         -- simplified numeric class
    (+), (-), (*), (/) :: a -> a -> a
    negate             :: a -> a
    fromInteger           :: Int -> a

-- Type class instances: ----------------------------------------------------

primitive primEqInt    "primEqInt",
      primLeInt    "primLeInt"   :: Int -> Int -> Bool
primitive primPlusInt  "primPlusInt",
      primMinusInt "primMinusInt",
      primDivInt   "primDivInt",
      primMulInt   "primMulInt"  :: Int -> Int -> Int
primitive primNegInt   "primNegInt"  :: Int -> Int

instance Eq ()  where () == () = True
instance Ord () where () <= () = True

instance Eq Int  where (==) = primEqInt

instance Ord Int where (<=) = primLeInt

instance Ix Int where
    range (m,n)      = [m..n]
    index (m,n) i    = i - m
    inRange (m,n) i  = m <= i && i <= n

instance Enum Int where
    enumFrom n       = iterate (1+) n
    enumFromThen n m = iterate ((m-n)+) n

instance Num Int where
    (+)           = primPlusInt
    (-)           = primMinusInt
    (*)           = primMulInt
    (/)           = primDivInt
    negate        = primNegInt
    fromInteger x = x

{- PC version off -}
primitive primEqFloat    "primEqFloat",
          primLeFloat    "primLeFloat"    :: Float -> Float -> Bool
primitive primPlusFloat  "primPlusFloat",
          primMinusFloat "primMinusFloat",
          primDivFloat   "primDivFloat",
          primMulFloat   "primMulFloat"   :: Float -> Float -> Float
primitive primNegFloat   "primNegFloat"   :: Float -> Float
primitive primIntToFloat "primIntToFloat" :: Int -> Float

instance Eq Float where (==) = primEqFloat

instance Ord Float where (<=) = primLeFloat

instance Enum Float where
    enumFrom n       = iterate (1.0+) n
    enumFromThen n m = iterate ((m-n)+) n

instance Num Float where
    (+)         = primPlusFloat
    (-)         = primMinusFloat
    (*)         = primMulFloat
    (/)         = primDivFloat
    negate      = primNegFloat
    fromInteger = primIntToFloat

primitive sin "primSinFloat",  asin  "primAsinFloat",
          cos "primCosFloat",  acos  "primAcosFloat",
      tan "primTanFloat",  atan  "primAtanFloat",
          log "primLogFloat",  log10 "primLog10Float",
      exp "primExpFloat",  sqrt  "primSqrtFloat" :: Float -> Float
primitive atan2    "primAtan2Float" :: Float -> Float -> Float
primitive truncate "primFloatToInt" :: Float -> Int

pi :: Float
pi  = 3.1415926535

{- PC version on -}

primitive primEqChar   "primEqChar",
      primLeChar   "primLeChar"  :: Char -> Char -> Bool

instance Eq Char  where (==) = primEqChar   -- c == d  =  ord c == ord d

instance Ord Char where (<=) = primLeChar   -- c <= d  =  ord c <= ord d

instance Ix Char where
    range (c,c')      = [c..c']
    index (c,c') ci   = ord ci - ord c
    inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci

instance Enum Char where
    enumFrom c        = map chr [ord c .. ord maxChar]
    enumFromThen c c' = map chr [ord c, ord c' .. ord lastChar]
                        where lastChar = if c' < c then minChar else maxChar

instance Eq a => Eq [a] where
    []     == []     =  True
    []     == (y:ys) =  False
    (x:xs) == []     =  False
    (x:xs) == (y:ys) =  x==y && xs==ys

instance Ord a => Ord [a] where
    []     <= _      =  True
    (_:_)  <= []     =  False
    (x:xs) <= (y:ys) =  x<y || (x==y && xs<=ys)

instance (Eq a, Eq b) => Eq (a,b) where
    (x,y) == (u,v)  =  x==u && y==v

instance (Ord a, Ord b) => Ord (a,b) where
    (x,y) <= (u,v)  = x<u  ||  (x==u && y<=v)

instance Eq Bool where
    True  == True   =  True
    False == False  =  True
    _     == _      =  False

instance Ord Bool where
    False <= x      = True
    True  <= x      = x

-- Standard numerical functions: --------------------------------------------

primitive div    "primDivInt",
      quot   "primQuotInt",
          rem    "primRemInt",
          mod    "primModInt"    :: Int -> Int -> Int

subtract  :: Num a => a -> a -> a
subtract   = flip (-)

even, odd :: Int -> Bool
even x     = x `rem` 2 == 0
odd        = not . even

gcd       :: Int -> Int -> Int
gcd x y    = gcd' (abs x) (abs y)
             where gcd' x 0 = x
                   gcd' x y = gcd' y (x `rem` y)

lcm       :: Int -> Int -> Int
lcm _ 0    = 0
lcm 0 _    = 0
lcm x y    = abs ((x `quot` gcd x y) * y)

(^)       :: Num a => a -> Int -> a
x ^ 0      = fromInteger 1
x ^ (n+1)  = f x n x
             where f _ 0 y = y
                   f x n y = g x n where
                             g x n | even n    = g (x*x) (n`quot`2)
                                   | otherwise = f x (n-1) (x*y)

abs                     :: (Num a, Ord a) => a -> a
abs x | x>=fromInteger 0 = x
      | otherwise        = -x

signum            :: (Num a, Ord a) => a -> Int
signum x
      | x==fromInteger 0 = 0
      | x> fromInteger 0 = 1
      | otherwise        = -1

sum, product    :: Num a => [a] -> a
sum              = foldl' (+) (fromInteger 0)
product          = foldl' (*) (fromInteger 1)

sums, products    :: Num a => [a] -> [a]
sums             = scanl (+) (fromInteger 0)
products         = scanl (*) (fromInteger 1)

-- Standard list processing functions: --------------------------------------

head             :: [a] -> a
head (x:_)        = x

last             :: [a] -> a
last [x]          = x
last (_:xs)       = last xs

tail             :: [a] -> [a]
tail (_:xs)       = xs

init             :: [a] -> [a]
init [x]          = []
init (x:xs)       = x : init xs

(++)             :: [a] -> [a] -> [a]    -- append lists.  Associative with
[]     ++ ys      = ys                   -- left and right identity [].
(x:xs) ++ ys      = x:(xs++ys)

genericLength    :: Num a => [b] -> a
genericLength     = foldl' (\n _ -> n + fromInteger 1) (fromInteger 0)

length         :: [a] -> Int           -- calculate length of list
length            = foldl' (\n _ -> n+1) 0

(!!)             :: [a] -> Int -> a      -- xs!!n selects the nth element of
(x:_)  !! 0       = x                    -- the list xs (first element xs!!0)
(_:xs) !! (n+1)   = xs !! n              -- for any n < length xs.

iterate          :: (a -> a) -> a -> [a] -- generate the infinite list
iterate f x       = x : iterate f (f x)  -- [x, f x, f (f x), ...

repeat           :: a -> [a]             -- generate the infinite list
repeat x          = xs where xs = x:xs   -- [x, x, x, x, ...

cycle            :: [a] -> [a]           -- generate the infinite list
cycle xs          = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ...

copy             :: Int -> a -> [a]      -- make list of n copies of x
copy n x          = take n xs where xs = x:xs

nub              :: Eq a => [a] -> [a]   -- remove duplicates from list
nub []            = []
nub (x:xs)        = x : nub (filter (x/=) xs)

reverse          :: [a] -> [a]           -- reverse elements of list
reverse           = foldl (flip (:)) []

elem, notElem    :: Eq a => a -> [a] -> Bool
elem              = any . (==)           -- test for membership in list
notElem           = all . (/=)           -- test for non-membership

maximum, minimum :: Ord a => [a] -> a
maximum           = foldl1 max          -- max element in non-empty list
minimum           = foldl1 min          -- min element in non-empty list

concat           :: [[a]] -> [a]        -- concatenate list of lists
concat            = foldr (++) []

transpose        :: [[a]] -> [[a]]      -- transpose list of lists
transpose         = foldr
                      (\xs xss -> zipWith (:) xs (xss ++ repeat []))
                      []

-- null provides a simple and efficient way of determining whether a given
-- list is empty, without using (==) and hence avoiding a constraint of the
-- form Eq [a].

null             :: [a] -> Bool
null []           = True
null (_:_)        = False

-- (\\) is used to remove the first occurrence of each element in the second
-- list from the first list.  It is a kind of inverse of (++) in the sense
-- that  (xs ++ ys) \\ xs = ys for any finite list xs of proper values xs.

(\\)             :: Eq a => [a] -> [a] -> [a]
(\\)              = foldl del
                    where []     `del` _  = []
                          (x:xs) `del` y
                             | x == y     = xs
                             | otherwise  = x : xs `del